home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…stman Always Clicks Twice / ADC Developer CD (1993-01) (''The Postman Always Clicks Twice'')_iso / Dev.CD 199301.iso / Development Platforms / LISP Related / LISP Goodies / McCartney-library 1.1 / CODE / oodles-files / GWorld-view.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  5.8 KB  |  178 lines  |  [TEXT/CCL2]
  1. (in-package :oou)
  2. ;(oou-provide :GWorld-view)
  3. (provide :GWorld-view)
  4. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  5. ;; GWorld-view.Lisp
  6. ;;
  7. ;; Copyright © 1991 Northwestern University Institute for the Learning Sciences
  8. ;; All Rights Reserved
  9. ;;
  10. ;; author: Michael S. Engber
  11. ;;
  12. ;; Provides a class of views based on GWorlds
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14.  
  15. ;(oou-dependencies :simple-view-ce
  16. ;                  :GWorld-u
  17. ;                  )
  18. (require :simple-view-ce)
  19. (require :GWorld-u)
  20.  
  21. (export '(GWorld-view
  22.           GW-alloc GW-realloc GW-free
  23.           GWorld GW-depth GW-cTable GW-gDevice GW-init-flags GW-update-flags
  24.           with-locked-GWorld-view
  25.           ))
  26.  
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28.  
  29. (eval-when (:compile-toplevel :load-toplevel :execute)
  30.  
  31.   (defmacro with-locked-GWorld-view (gw-view &body body)
  32.     `(with-locked-GWorld (GWorld ,gw-view)
  33.        ;(GWorld-set-origin ,gw-view (view-origin ,gw-view))
  34.        ;this hack attempts to counteract the (#_SetOrigin 0 0) hack in focus-view
  35.        ;currently this is addressed in a patch so it's not needed.
  36.        ,@body))
  37.  
  38. )
  39.  
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41.  
  42. (defclass GWorld-view (view)
  43.   
  44.   ((GWorld           :accessor GWorld)
  45.    (GW-depth         :initarg :GW-depth
  46.                      :accessor GW-depth)
  47.    (GW-cTable        :initarg :GW-cTable
  48.                      :accessor GW-cTable)
  49.    (GW-gDevice       :initarg :GW-gDevice
  50.                      :accessor GW-gDevice)
  51.    (GW-init-flags    :initarg :GW-init-flags
  52.                      :accessor GW-init-flags)
  53.    (GW-update-flags  :initarg :GW-update-flags
  54.                      :accessor GW-update-flags)
  55.    )
  56.   
  57.   (:default-initargs
  58.     :GW-depth        8
  59.     :GW-cTable       (%null-ptr)
  60.     :GW-gDevice      (%null-ptr)
  61.     :GW-init-flags   0
  62.     :GW-update-flags 0
  63.     ))
  64.  
  65. ;(defmethod ccl::call-with-focused-view :around ((view GWorld-view) thunk &optional font-view)
  66. (defmethod call-with-focused-view :around ((view GWorld-view) thunk &optional font-view)
  67.   (declare (ignore thunk font-view))
  68.   (with-locked-GWorld-view view
  69.     (call-next-method)))
  70.  
  71. (defmethod wptr ((view GWorld-view)) (GWorld view))
  72.  
  73. (defmethod view-clip-region ((view GWorld-view))
  74.   nil
  75. ;(pref (wptr view) :CGrafPort.clipRgn)
  76. )
  77.  
  78. (defmethod set-view-position :after ((view GWorld-view) h &optional v)
  79.   (declare (ignore h v))
  80.   (GW-realloc view))
  81.  
  82. (defmethod set-view-size :after ((view GWorld-view) h &optional v)
  83.   (declare (ignore h v))
  84.   (GW-realloc view))
  85.  
  86. (defmethod invalidate-corners ((view GWorld-view) topLeft bottomRight &optional erase-p)
  87.   (declare (ignore v topLeft bottomRight erase-p)))
  88.  
  89. (defmethod invalidate-view ((view GWorld-view) &optional erase-p)
  90.   (declare (ignore view erase-p)))
  91.  
  92. (defmethod install-view-in-window ((view GWorld-view) window)
  93.   (declare (ignore view window))
  94.   (error "method illegal for GWorld-views."))
  95.  
  96. (defmethod remove-view-from-window ((view GWorld-view))
  97.   (declare (ignore view))
  98.   (error "method illegal for GWorld-views."))
  99.  
  100. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  101.  
  102. (defmethod GWorld-set-origin ((view GWorld-view) origin)
  103.   (declare (dynamic-extent view origin))
  104.   (setf (slot-value view 'view-origin) origin)
  105.   (when (GWorld-allocated-p view)
  106.     (rlet ((old-port_p :pointer)
  107.            (old-gdh_p  :pointer))
  108.       (#_GetGWorld old-port_p old-gdh_p)
  109.       (with-macptrs ((old-port (%get-ptr old-port_p))
  110.                      (old-gdh  (%get-ptr old-gdh_p)))
  111.         (if (eq view *current-view*)
  112.           (#_SetOrigin :long origin)
  113.           (without-interrupts
  114.            (unwind-protect
  115.              (progn
  116.                (#_SetGWorld (GWorld view) (%null-ptr))
  117.                (#_SetOrigin :long origin))
  118.              (#_SetGWorld old-port old-gdh)))))))
  119.   t)
  120.  
  121. (defmethod GWorld-set-portRect ((view GWorld-view) r)
  122.   (let ((tl (pref r :Rect.topLeft)))
  123.     (declare (dynamic-extent tl))
  124.     (setf (slot-value view 'view-position) tl)
  125.     (setf (slot-value view 'view-size) (subtract-points (pref r :Rect.botRight) tl))
  126.     (GW-realloc view))
  127.   t)
  128.  
  129. (defmethod GW-alloc ((view GWorld-view))
  130.   (unless (GWorld-allocated-p view)
  131.     (with-slots (GW-depth GW-cTable GW-gDevice GW-init-flags) view
  132.       (rlet ((gWorld_p :pointer (%null-ptr))
  133.              (r        :Rect
  134.                        :topLeft  (view-position view)
  135.                        :botRight (add-points (view-position view) (view-size view))))
  136.         (without-interrupts
  137.          (let ((ecode (#_NewGWorld gWorld_p GW-depth r GW-cTable GW-gDevice GW-init-flags)))
  138.            (declare (dynamic-extent ecode))
  139.            (unless (zerop ecode) (error "unable to allocate GWorld (~a)" ecode)))
  140.          (setf (GWorld view) (%get-ptr gWorld_p)))
  141.         (when (zerop GW-depth)
  142.           (GWorld-set-origin view (view-position view)))))
  143.     t))
  144.  
  145. (defmethod GW-realloc ((view GWorld-view))
  146.   (with-slots (GW-depth GW-cTable GW-gDevice GW-update-flags) view
  147.     (rlet ((gWorld_p :pointer (GWorld view))
  148.            (r        :Rect
  149.                      :topLeft  (view-position view)
  150.                      :botRight (add-points (view-position view) (view-size view))))
  151.       (without-interrupts
  152.        (let ((ecode (#_UpdateGWorld gWorld_p GW-depth r GW-cTable GW-gDevice GW-update-flags)))
  153.          (declare (dynamic-extent ecode))
  154.          (when (minusp ecode)
  155.            (error "unable to update GWorld (~a)" ecode)))
  156.        (setf (GWorld view) (%get-ptr gWorld_p)))
  157.       (when (zerop GW-depth)
  158.         (GWorld-set-origin view (view-position view)))))
  159.   t)
  160.  
  161. (defmethod GW-free ((view GWorld-view))
  162.   (#_DisposeGWorld (GWorld view))
  163.   (slot-makunbound view 'GWorld)
  164.   t)
  165.  
  166. (defmethod GWorld-allocated-p ((view GWorld-view))
  167.   (slot-boundp view 'GWorld))
  168.  
  169. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  170.  
  171.  
  172. #|
  173.  
  174.  
  175. example code can be found in kinesis-u
  176.   
  177.  
  178. |#